home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / os2 / octa209s.zip / octave-2.09 / libcruft / lapack / dlasrt.f < prev    next >
Text File  |  1996-07-19  |  6KB  |  245 lines
  1.       SUBROUTINE DLASRT( ID, N, D, INFO )
  2. *
  3. *  -- LAPACK routine (version 2.0) --
  4. *     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
  5. *     Courant Institute, Argonne National Lab, and Rice University
  6. *     September 30, 1994
  7. *
  8. *     .. Scalar Arguments ..
  9.       CHARACTER          ID
  10.       INTEGER            INFO, N
  11. *     ..
  12. *     .. Array Arguments ..
  13.       DOUBLE PRECISION   D( * )
  14. *     ..
  15. *
  16. *  Purpose
  17. *  =======
  18. *
  19. *  Sort the numbers in D in increasing order (if ID = 'I') or
  20. *  in decreasing order (if ID = 'D' ).
  21. *
  22. *  Use Quick Sort, reverting to Insertion sort on arrays of
  23. *  size <= 20. Dimension of STACK limits N to about 2**32.
  24. *
  25. *  Arguments
  26. *  =========
  27. *
  28. *  ID      (input) CHARACTER*1
  29. *          = 'I': sort D in increasing order;
  30. *          = 'D': sort D in decreasing order.
  31. *
  32. *  N       (input) INTEGER
  33. *          The length of the array D.
  34. *
  35. *  D       (input/output) DOUBLE PRECISION array, dimension (N)
  36. *          On entry, the array to be sorted.
  37. *          On exit, D has been sorted into increasing order
  38. *          (D(1) <= ... <= D(N) ) or into decreasing order
  39. *          (D(1) >= ... >= D(N) ), depending on ID.
  40. *
  41. *  INFO    (output) INTEGER
  42. *          = 0:  successful exit
  43. *          < 0:  if INFO = -i, the i-th argument had an illegal value
  44. *
  45. *  =====================================================================
  46. *
  47. *     .. Parameters ..
  48.       INTEGER            SELECT
  49.       PARAMETER          ( SELECT = 20 )
  50. *     ..
  51. *     .. Local Scalars ..
  52.       INTEGER            DIR, ENDD, I, J, START, STKPNT
  53.       DOUBLE PRECISION   D1, D2, D3, DMNMX, TMP
  54. *     ..
  55. *     .. Local Arrays ..
  56.       INTEGER            STACK( 2, 32 )
  57. *     ..
  58. *     .. External Functions ..
  59.       LOGICAL            LSAME
  60.       EXTERNAL           LSAME
  61. *     ..
  62. *     .. External Subroutines ..
  63.       EXTERNAL           XERBLA
  64. *     ..
  65. *     .. Executable Statements ..
  66. *
  67. *     Test the input paramters.
  68. *
  69.       INFO = 0
  70.       DIR = -1
  71.       IF( LSAME( ID, 'D' ) ) THEN
  72.          DIR = 0
  73.       ELSE IF( LSAME( ID, 'I' ) ) THEN
  74.          DIR = 1
  75.       END IF
  76.       IF( DIR.EQ.-1 ) THEN
  77.          INFO = -1
  78.       ELSE IF( N.LT.0 ) THEN
  79.          INFO = -2
  80.       END IF
  81.       IF( INFO.NE.0 ) THEN
  82.          CALL XERBLA( 'DLASRT', -INFO )
  83.          RETURN
  84.       END IF
  85. *
  86. *     Quick return if possible
  87. *
  88.       IF( N.LE.1 )
  89.      $   RETURN
  90. *
  91.       STKPNT = 1
  92.       STACK( 1, 1 ) = 1
  93.       STACK( 2, 1 ) = N
  94.    10 CONTINUE
  95.       START = STACK( 1, STKPNT )
  96.       ENDD = STACK( 2, STKPNT )
  97.       STKPNT = STKPNT - 1
  98.       IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
  99. *
  100. *        Do Insertion sort on D( START:ENDD )
  101. *
  102.          IF( DIR.EQ.0 ) THEN
  103. *
  104. *           Sort into decreasing order
  105. *
  106.             DO 30 I = START + 1, ENDD
  107.                DO 20 J = I, START + 1, -1
  108.                   IF( D( J ).GT.D( J-1 ) ) THEN
  109.                      DMNMX = D( J )
  110.                      D( J ) = D( J-1 )
  111.                      D( J-1 ) = DMNMX
  112.                   ELSE
  113.                      GO TO 30
  114.                   END IF
  115.    20          CONTINUE
  116.    30       CONTINUE
  117. *
  118.          ELSE
  119. *
  120. *           Sort into increasing order
  121. *
  122.             DO 50 I = START + 1, ENDD
  123.                DO 40 J = I, START + 1, -1
  124.                   IF( D( J ).LT.D( J-1 ) ) THEN
  125.                      DMNMX = D( J )
  126.                      D( J ) = D( J-1 )
  127.                      D( J-1 ) = DMNMX
  128.                   ELSE
  129.                      GO TO 50
  130.                   END IF
  131.    40          CONTINUE
  132.    50       CONTINUE
  133. *
  134.          END IF
  135. *
  136.       ELSE IF( ENDD-START.GT.SELECT ) THEN
  137. *
  138. *        Partition D( START:ENDD ) and stack parts, largest one first
  139. *
  140. *        Choose partition entry as median of 3
  141. *
  142.          D1 = D( START )
  143.          D2 = D( ENDD )
  144.          I = ( START+ENDD ) / 2
  145.          D3 = D( I )
  146.          IF( D1.LT.D2 ) THEN
  147.             IF( D3.LT.D1 ) THEN
  148.                DMNMX = D1
  149.             ELSE IF( D3.LT.D2 ) THEN
  150.                DMNMX = D3
  151.             ELSE
  152.                DMNMX = D2
  153.             END IF
  154.          ELSE
  155.             IF( D3.LT.D2 ) THEN
  156.                DMNMX = D2
  157.             ELSE IF( D3.LT.D1 ) THEN
  158.                DMNMX = D3
  159.             ELSE
  160.                DMNMX = D1
  161.             END IF
  162.          END IF
  163. *
  164.          IF( DIR.EQ.0 ) THEN
  165. *
  166. *           Sort into decreasing order
  167. *
  168.             I = START - 1
  169.             J = ENDD + 1
  170.    60       CONTINUE
  171.    70       CONTINUE
  172.             J = J - 1
  173.             IF( D( J ).LT.DMNMX )
  174.      $         GO TO 70
  175.    80       CONTINUE
  176.             I = I + 1
  177.             IF( D( I ).GT.DMNMX )
  178.      $         GO TO 80
  179.             IF( I.LT.J ) THEN
  180.                TMP = D( I )
  181.                D( I ) = D( J )
  182.                D( J ) = TMP
  183.                GO TO 60
  184.             END IF
  185.             IF( J-START.GT.ENDD-J-1 ) THEN
  186.                STKPNT = STKPNT + 1
  187.                STACK( 1, STKPNT ) = START
  188.                STACK( 2, STKPNT ) = J
  189.                STKPNT = STKPNT + 1
  190.                STACK( 1, STKPNT ) = J + 1
  191.                STACK( 2, STKPNT ) = ENDD
  192.             ELSE
  193.                STKPNT = STKPNT + 1
  194.                STACK( 1, STKPNT ) = J + 1
  195.                STACK( 2, STKPNT ) = ENDD
  196.                STKPNT = STKPNT + 1
  197.                STACK( 1, STKPNT ) = START
  198.                STACK( 2, STKPNT ) = J
  199.             END IF
  200.          ELSE
  201. *
  202. *           Sort into increasing order
  203. *
  204.             I = START - 1
  205.             J = ENDD + 1
  206.    90       CONTINUE
  207.   100       CONTINUE
  208.             J = J - 1
  209.             IF( D( J ).GT.DMNMX )
  210.      $         GO TO 100
  211.   110       CONTINUE
  212.             I = I + 1
  213.             IF( D( I ).LT.DMNMX )
  214.      $         GO TO 110
  215.             IF( I.LT.J ) THEN
  216.                TMP = D( I )
  217.                D( I ) = D( J )
  218.                D( J ) = TMP
  219.                GO TO 90
  220.             END IF
  221.             IF( J-START.GT.ENDD-J-1 ) THEN
  222.                STKPNT = STKPNT + 1
  223.                STACK( 1, STKPNT ) = START
  224.                STACK( 2, STKPNT ) = J
  225.                STKPNT = STKPNT + 1
  226.                STACK( 1, STKPNT ) = J + 1
  227.                STACK( 2, STKPNT ) = ENDD
  228.             ELSE
  229.                STKPNT = STKPNT + 1
  230.                STACK( 1, STKPNT ) = J + 1
  231.                STACK( 2, STKPNT ) = ENDD
  232.                STKPNT = STKPNT + 1
  233.                STACK( 1, STKPNT ) = START
  234.                STACK( 2, STKPNT ) = J
  235.             END IF
  236.          END IF
  237.       END IF
  238.       IF( STKPNT.GT.0 )
  239.      $   GO TO 10
  240.       RETURN
  241. *
  242. *     End of DLASRT
  243. *
  244.       END
  245.